home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / wsfont / wsfonts.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1995-05-02  |  9.4 KB  |  336 lines
  1. VERSION 2.00
  2. Begin Form Form1 
  3.    BackColor       =   &H00C0C0C0&
  4.    BorderStyle     =   3  'Fixed Double
  5.    Caption         =   "Font Manager"
  6.    ClientHeight    =   3780
  7.    ClientLeft      =   2220
  8.    ClientTop       =   2355
  9.    ClientWidth     =   7890
  10.    FillColor       =   &H00C0C0C0&
  11.    FillStyle       =   5  'Downward Diagonal
  12.    ForeColor       =   &H00000000&
  13.    Height          =   4470
  14.    Icon            =   WSFONTS.FRX:0000
  15.    Left            =   2160
  16.    LinkTopic       =   "Form1"
  17.    MaxButton       =   0   'False
  18.    ScaleHeight     =   3780
  19.    ScaleWidth      =   7890
  20.    Top             =   1725
  21.    Width           =   8010
  22.    Begin CommonDialog CMDialog1 
  23.       Left            =   3600
  24.       Top             =   120
  25.    End
  26.    Begin CommandButton Command1 
  27.       BackColor       =   &H00FF0000&
  28.       Caption         =   "
  29.       FontBold        =   0   'False
  30.       FontItalic      =   0   'False
  31.       FontName        =   "MS Sans Serif"
  32.       FontSize        =   8.25
  33.       FontStrikethru  =   0   'False
  34.       FontUnderline   =   0   'False
  35.       Height          =   375
  36.       Index           =   1
  37.       Left            =   3480
  38.       TabIndex        =   3
  39.       Top             =   1800
  40.       Width           =   855
  41.    End
  42.    Begin CommandButton Command1 
  43.       BackColor       =   &H00FF0000&
  44.       Caption         =   "
  45.       FontBold        =   0   'False
  46.       FontItalic      =   0   'False
  47.       FontName        =   "MS Sans Serif"
  48.       FontSize        =   8.25
  49.       FontStrikethru  =   0   'False
  50.       FontUnderline   =   0   'False
  51.       Height          =   375
  52.       Index           =   0
  53.       Left            =   3480
  54.       TabIndex        =   2
  55.       Top             =   1080
  56.       Width           =   855
  57.    End
  58.    Begin ListBox List2 
  59.       FontBold        =   0   'False
  60.       FontItalic      =   0   'False
  61.       FontName        =   "MS Sans Serif"
  62.       FontSize        =   8.25
  63.       FontStrikethru  =   0   'False
  64.       FontUnderline   =   0   'False
  65.       Height          =   2760
  66.       Left            =   4440
  67.       MultiSelect     =   2  'Extended
  68.       Sorted          =   -1  'True
  69.       TabIndex        =   5
  70.       Top             =   480
  71.       Width           =   3300
  72.    End
  73.    Begin ListBox List1 
  74.       FontBold        =   0   'False
  75.       FontItalic      =   0   'False
  76.       FontName        =   "MS Sans Serif"
  77.       FontSize        =   8.25
  78.       FontStrikethru  =   0   'False
  79.       FontUnderline   =   0   'False
  80.       Height          =   2760
  81.       Left            =   120
  82.       MultiSelect     =   2  'Extended
  83.       Sorted          =   -1  'True
  84.       TabIndex        =   1
  85.       Top             =   480
  86.       Width           =   3300
  87.    End
  88.    Begin Label Label2 
  89.       AutoSize        =   -1  'True
  90.       BackStyle       =   0  'Transparent
  91.       Caption         =   "label2"
  92.       FontBold        =   0   'False
  93.       FontItalic      =   0   'False
  94.       FontName        =   "MS Sans Serif"
  95.       FontSize        =   8.25
  96.       FontStrikethru  =   0   'False
  97.       FontUnderline   =   0   'False
  98.       Height          =   195
  99.       Left            =   120
  100.       TabIndex        =   6
  101.       Top             =   3555
  102.       Width           =   420
  103.    End
  104.    Begin Line Line2 
  105.       BorderColor     =   &H00808080&
  106.       X1              =   1560
  107.       X2              =   3840
  108.       Y1              =   3480
  109.       Y2              =   3480
  110.    End
  111.    Begin Line Line1 
  112.       BorderColor     =   &H00FFFFFF&
  113.       X1              =   2520
  114.       X2              =   6240
  115.       Y1              =   3480
  116.       Y2              =   3480
  117.    End
  118.    Begin Label Label1 
  119.       AutoSize        =   -1  'True
  120.       BackStyle       =   0  'Transparent
  121.       Caption         =   "&Reserve Fonts:"
  122.       ForeColor       =   &H00000000&
  123.       Height          =   195
  124.       Index           =   1
  125.       Left            =   4440
  126.       TabIndex        =   4
  127.       Top             =   240
  128.       Width           =   1305
  129.    End
  130.    Begin Label Label1 
  131.       AutoSize        =   -1  'True
  132.       BackStyle       =   0  'Transparent
  133.       Caption         =   "&Installed Fonts:"
  134.       ForeColor       =   &H00000000&
  135.       Height          =   195
  136.       Index           =   0
  137.       Left            =   120
  138.       TabIndex        =   0
  139.       Top             =   225
  140.       Width           =   1320
  141.    End
  142.    Begin Menu fMenu 
  143.       Caption         =   "&File"
  144.       Begin Menu fItem 
  145.          Caption         =   "P&rint Setup..."
  146.          Index           =   0
  147.       End
  148.       Begin Menu fItem 
  149.          Caption         =   "-"
  150.          Index           =   1
  151.       End
  152.       Begin Menu fItem 
  153.          Caption         =   "E&xit"
  154.          Index           =   2
  155.       End
  156.    End
  157. Option Explicit
  158. Option Compare Text
  159. DefInt A-Z
  160. Dim bf$(22)
  161. Sub BuildBasics ()
  162. bf$(0) = "Arial (TrueType)"
  163. bf$(1) = "Arial Bold (TrueType)"
  164. bf$(2) = "Arial Bold Italic (TrueType)"
  165. bf$(3) = "Arial Italic (TrueType)"
  166. bf$(4) = "Courier New (TrueType)"
  167. bf$(5) = "Courier New Bold (TrueType)"
  168. bf$(6) = "Courier New Bold Italic (TrueType)"
  169. bf$(7) = "Courier New Italic (TrueType)"
  170. bf$(8) = "Times New Roman (TrueType)"
  171. bf$(9) = "Times New Roman Bold (TrueType)"
  172. bf$(10) = "Times New Roman Bold Italic (TrueType)"
  173. bf$(11) = "Times New Roman Italic (TrueType)"
  174. bf$(12) = "Wingdings (TrueType)"
  175. bf$(13) = "Symbol (TrueType)"
  176. bf$(14) = "System"
  177. bf$(15) = "Modern (Plotter)"
  178. bf$(16) = "Roman (Plotter)"
  179. bf$(17) = "Script (Plotter)"
  180. bf$(18) = "Terminal"
  181. bf$(19) = "Symbol 8"
  182. bf$(20) = "MS Sans Serif"
  183. bf$(21) = "MS Serif"
  184. bf$(22) = "Small ("
  185. End Sub
  186. Sub Callback1_EnumFonts (lpLogFont As Long, lpTextMetrics As Long, nFontTYpe As Integer, lpData As Long, Retval As Integer)
  187. Debug.Print lpLogFont, lpTextMetrics, nFontTYpe, lpData, Retval
  188. End Sub
  189. Function CheckBasics% (fName$)
  190. Dim X%
  191. CheckBasics% = False
  192. For X% = 0 To 19
  193.    If fName$ = bf$(X%) Then CheckBasics% = True: Exit Function
  194. '   If fName$ + " (TrueType)" = bf$(X%) Then CheckBasics% = True: Exit Function
  195. For X% = 20 To 22
  196.    If InStr(fName$, bf$(X%)) Then CheckBasics% = True: Exit Function
  197. End Function
  198. Sub CheckReserveListCount ()
  199. If List2.ListCount > 0 Then
  200.    Command1(1).Enabled = True
  201.    Command1(1).Enabled = False
  202. End If
  203. End Sub
  204. Sub Command1_Click (Index As Integer)
  205. Command1(0).Enabled = False
  206. Command1(1).Enabled = False
  207. Dim y%, Z%, F$, fc%
  208. Screen.MousePointer = 11
  209. Select Case Index
  210. Case 0   'move to wsfonts
  211.    For y% = List1.ListCount - 1 To 0 Step -1
  212.       MoveBasic% = True
  213.       If List1.Selected(y%) Then
  214.          F$ = List1.List(y%)
  215.          Z% = CheckBasics%(F$)
  216.          If Z% = True Then
  217.             TestFont$ = F$
  218.             Screen.MousePointer = 0
  219.             ConfirmScreen.Show 1
  220.             Screen.MousePointer = 11
  221.          End If
  222.          If MoveBasic% = True Then
  223.             Label2 = "Deactivating " + F$
  224.             Label2.Refresh
  225.             If UninStall%(F$) = True Then
  226.                List2.AddItem F$
  227.                List1.RemoveItem y%
  228.             End If
  229.          End If
  230.       End If
  231.    Next
  232. Case 1   'install
  233.    For y% = List2.ListCount - 1 To 0 Step -1
  234.       If List2.Selected(y%) Then
  235.          F$ = List2.List(y%)
  236.          Label2 = "Activating " + F$
  237.          Label2.Refresh
  238.          If Install%(F$) = True Then
  239.             List1.AddItem F$
  240.             List2.RemoveItem y%
  241.          End If
  242.       End If
  243.    Next
  244. End Select
  245. BroadcastIniChange
  246. CheckReserveListCount
  247. Label2 = ""
  248. Screen.MousePointer = 0
  249. Command1(0).Enabled = True
  250. Command1(1).Enabled = True
  251. End Sub
  252. Sub fItem_Click (Index As Integer)
  253. Select Case Index
  254. Case 0
  255.       CMDialog1.Flags = &H40&
  256.       CMDialog1.PrinterDefault = True
  257.       CMDialog1.CancelError = True
  258.       On Error Resume Next
  259.       CMDialog1.Action = 5
  260.       If Err = 32755 Then Exit Sub
  261.       On Error GoTo 0
  262. Case 1
  263. Case 2
  264.    Unload Me
  265. End Select
  266. End Sub
  267. Sub Form_Load ()
  268. Label2 = ""
  269. CRLF$ = Chr$(13) + Chr$(10)
  270. Screen.MousePointer = 11
  271. Refresh
  272. BuildBasics
  273. Dim X%, Temp$, Z%
  274. 'load installed fonts from Win.INI
  275. Z% = 1
  276. Temp$ = ListWinIniEntries$("Fonts")
  277. X% = InStr(Temp$, Chr$(0))
  278. Do While X%
  279.    If X% = 1 Then Exit Do
  280.    List1.AddItem Mid$(Temp$, Z%, X%)
  281.    Z% = X% + 1
  282.    X% = InStr(Z%, Temp$, Chr$(0))
  283. 'insert load reserve fonts code here
  284. Z% = 1
  285. Temp$ = ListPrivateIniEntries$("Fonts", "WSFONTS.INI")
  286. X% = InStr(Temp$, Chr$(0))
  287. Do While X%
  288.    If X% = 1 Then Exit Do
  289.    List2.AddItem Mid$(Temp$, Z%, X%)
  290.    Z% = X% + 1
  291.    X% = InStr(Z%, Temp$, Chr$(0))
  292. CheckReserveListCount
  293. Screen.MousePointer = 0
  294. End Sub
  295. Sub Form_Paint ()
  296. Line1.X1 = 0
  297. Line1.X2 = Width
  298. Line2.X1 = 0
  299. Line2.X2 = Width
  300. Line2.Y1 = Line1.Y1 + 15
  301. Line2.Y2 = Line1.Y2 + 15
  302. End Sub
  303. Sub List1_Click ()
  304. Set ActiveC = List1
  305. UpdateForm
  306. End Sub
  307. Sub List1_DblClick ()
  308. UpdateForm
  309. End Sub
  310. Sub List2_Click ()
  311. Set ActiveC = List2
  312. UpdateForm
  313. End Sub
  314. Sub List2_DblClick ()
  315. UpdateForm
  316. End Sub
  317. Sub List2_GotFocus ()
  318. List1.ListIndex = -1
  319. End Sub
  320. Sub UpdateForm ()
  321. Select Case ActiveC.SelCount
  322. Case 0
  323.    Label2 = ""
  324. Case 1
  325.    Label2 = ActiveC
  326. Case Else
  327.    Label2 = ActiveC.SelCount & " items selected"
  328. End Select
  329. Dim Test$, fFamily$, fName$, fType$, X%, y%
  330. TestFont$ = ActiveC.List(ActiveC.ListIndex)
  331. If ActiveC = Form1.List2 Then
  332.    Test$ = GetPrivINI$("fonts", TestFont$, "uh-oh", "WSFONTS.INI")
  333.    Test$ = GetWinINI$("fonts", TestFont$, "uh-oh")
  334. End If
  335. End Sub
  336.